home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
EnigmA Amiga Run 1995 November
/
EnigmA AMIGA RUN 02 (1995)(G.R. Edizioni)(IT)[!][issue 1995-11][Skylink CD].iso
/
earcd
/
program
/
misc
/
lvodump.lha
/
LVODump.p
< prev
next >
Wrap
Text File
|
1995-08-31
|
15KB
|
538 lines
{ ************************************************************************ }
{ ************************************************************************ }
{ ************************** ************************** }
{ ************************ } PROGRAM LVODump; { ************************ }
{ ************************** ************************** }
{ ************************************************************************ }
{ ************************************************************************ }
{ ** ** }
{ ** This programs prints to standard output a list of Library Vectors ** }
{ ** Offsets for the library specified as the parameter, in a format ** }
{ ** very similar to that of RKM: Libraries and Devices, appendix D. ** }
{ ** ** }
{ ** The .fd file can be specified without the complete path if it is ** }
{ ** either in the current directory or in the fd: logical volume. ** }
{ ** ** }
{ ************************************************************************ }
{ ** ** }
{ ** Created by Marco Favaretto ** }
{ ** ------------------------------------------- ** }
{ ** Compiled with KickPascal 2.10 ** }
{ ** ** }
{ ************************************************************************ }
{ ** ** }
{ ** History: ** }
{ ** ** }
{ ** 950831 1.0 First release ** }
{ ** ** }
{ ************************************************************************ }
{ ************************************************************************ }
{$OPT A-,B-,I-,S-,T-} { all compiler options off }
CONST
YES = TRUE; { boolean value }
NO = FALSE; { boolean value }
HEAD = 1; { see RemoveSpaces() }
TAIL = 2; { see RemoveSpaces() }
BIASSTEP = 6; { bias step, right! }
SPACE = ' '; { word & output columns separator }
TAB = #$09; { output columns separator }
LF = #$0A; { input terminator }
COMMA = ','; { template separator }
COLON = ':'; { template/option list separator }
SLASH = '/'; { template separator }
POINT = '.'; { option list terminator }
EMPTYSTRING = '';
MAXSTRLEN = 255;
TEMPLATEREQUEST = '?'; { user request for template }
TYPE
{ ___ IMPORTANT: do not modify the order of ErrorType options, because ___ }
{ ___ doing so will alter the errorcodes of the program ___ }
ErrorType = (SYNTAX, NOFILENAME, FILENOTFOUND, NOBIAS, INVALIDBIAS,
UNKNOWNDIRECTIVE);
{ ___ IMPORTANT: do not modify the order of ParamType and DirectiveType __ }
{ ___ options; otherwise, you MUST modify the related string __ }
{ ___ definition in LVODumpSupport.s in the same way. __ }
ParamType = (UNKNOWN_PAR, FILENAME_PAR, NOTAB_PAR, NOHEADER_PAR,
NOBASE_PAR, NOPRIVATE_PAR);
DirectiveType = (UNKNOWN_DIR, BASE_DIR, BIAS_DIR, PRIVATE_DIR,
PUBLIC_DIR, END_DIR);
InString = string[MAXSTRLEN]; { for readln from text files, so }
{ the length is no longer limited }
{ to 80 chars per line }
VAR
InFile: TEXT; { .fd file in input }
InLine: InString; { a line from input file }
FName: string; { .fd file name }
Bias: long; { library vector offset counter }
BaseName: string; { name of library base }
Separator: char; { column separator }
PrintHeader: boolean; { flag for output header }
PrintBase: boolean; { flag for output basename }
PrintPrivate: boolean; { flag for private LVO output }
HeaderOut: boolean; { flag for header (NOT) printed }
IsPublic: boolean; { flag for private LVO }
{ ___ Following vars are uses as Typed Constants with predefined values __ }
{ ___ (look at LVODumpSupport.s) __ }
CTEMPLATE: string; IMPORT; { COMMA + command template }
TEMPLATE: string; IMPORT; { command template }
CDIRECTIVES: string; IMPORT; { COMMA + list of .fd directives }
DIRECTIVES: string; IMPORT; { list of .fd directives }
FNAMEEND: string; IMPORT; { the .fd files ends this way }
FDPATH: string; IMPORT; { logical volume for .fd. files }
BANNER: string; IMPORT; { copyright message and syntax }
{$LINK 'LVODumpSupport.o'}
PROCEDURE UpCaseStr(VAR a0:InString); EXTERNAL;
{ ___ Output error message and terminate program _________________________ }
{ ________________________________________________________________________ }
PROCEDURE ShowError(er: ErrorType);
VAR
s: InString;
Begin
CASE er OF
SYNTAX: write(BANNER);
NOFILENAME: write('Missing filename.');
FILENOTFOUND: write('File not found: ' + FName);
NOBIAS: write(FName + ': missing bias directive.');
INVALIDBIAS: write(FName + ': invalid bias value.');
UNKNOWNDIRECTIVE: write(FName + ': unknown directive.')
End;
IF er > FILENOTFOUND THEN { in this case (only) InFile is open }
Close(InFile);
Halt(ord(er) + 21) { exit error code }
End;
{ ___ Remove head and tail spaces from a string __________________________ }
{ ________________________________________________________________________ }
FUNCTION RemoveSpaces(s:InString, Where:byte): InString;
VAR
First, Last: byte;
Begin
First := 1;
IF (Where AND HEAD) = HEAD THEN
WHILE (s[First] IN [SPACE, TAB]) DO
Inc(First);
Last := length(s);
IF (Where AND TAIL) = TAIL THEN
WHILE (Last >= First) AND (s[Last] IN [SPACE, TAB, LF]) DO
Dec(Last);
RemoveSpaces := copy(s, First, Last-First+1)
End;
{ ___ Extract (and possibly remove) the first word from a string _________ }
{ ________________________________________________________________________ }
FUNCTION GetFirstWord(VAR s:InString, cut:boolean): InString;
VAR
z: byte;
Begin
z := pos(SPACE,s);
IF z = 0 THEN Begin
z := pos(TAB,s);
IF z = 0 THEN
z := length(s) + 1
End;
GetFirstWord := copy(s,1,z-1);
IF cut THEN
s := RemoveSpaces(copy(s,z,MAXSTRLEN), HEAD)
End;
{ ___ Convert a long to hexadecimal string of p chars ____________________ }
{ ________________________________________________________________________ }
FUNCTION Hex(n:long, p:byte):string;
CONST
HEXDIGITS='0123456789ABCDEF';
VAR
s: string[9];
z: byte;
Begin
z := 9;
s := '000000000';
WHILE n > 0 DO Begin
Dec(z);
s[z] := HEXDIGITS.[(n MOD 16)+1];
n := n DIV 16
End;
Hex := copy(s,9-p,p)
End;
{ ___ Compare an option (string) with a list of options __________________ }
{ ________________________________________________________________________ }
FUNCTION CheckOption(Pattern: string; Opt:InString): integer;
VAR
z: byte;
s: string;
p_s: str;
c: integer;
Begin
c := 0;
s := COMMA + Opt + SLASH;
z := pos(s, Pattern);
IF z = 0 THEN Begin
s := COMMA + Opt + COMMA;
z := pos(s, Pattern);
IF z = 0 THEN Begin
s := COMMA + Opt + COLON;
z := pos(s, Pattern);
IF z = 0 THEN Begin
s := COMMA + Opt + POINT;
z := pos(s, Pattern);
IF z = 0 THEN Begin
CheckOption := c;
Exit
End
End
End
End;
s := copy(Pattern, 1, z-1);
p_s := s;
REPEAT
Inc(c);
z := pos(COMMA, p_s);
p_s := str(long(p_s)+z)
UNTIL z = 0;
CheckOption := c
End;
{ ___ Compare each parameter on command line with template _______________ }
{ ________________________________________________________________________ }
FUNCTION CheckParameter(Param: InString): ParamType;
VAR
z: integer;
cp: ParamType;
Begin
UpCaseStr(Param);
z := CheckOption(CTEMPLATE, Param);
cp := UNKNOWN_PAR;
WHILE z > 0 DO Begin
cp := succ(cp);
Dec(z)
End;
CheckParameter := cp
End;
{ ___ Analyse the parameter line _________________________________________ }
{ ________________________________________________________________________ }
PROCEDURE AnalyzeParameterLine;
VAR
ParmLine: InString;
Param: InString;
Begin
ParmLine := RemoveSpaces(copy(parameterstr,1,parameterlen), HEAD + TAIL);
IF ParmLine = EMPTYSTRING THEN
ShowError(NOFILENAME);
{$OPT B+} { let the user break from here... }
WHILE ParmLine = TEMPLATEREQUEST DO Begin
write(TEMPLATE);
readln(ParmLine);
ParmLine := RemoveSpaces(ParmLine, HEAD + TAIL)
End;
{$OPT B-} { ...to here. }
WHILE ParmLine > EMPTYSTRING DO Begin
Param := GetFirstWord(ParmLine, YES);
CASE CheckParameter(Param) OF
UNKNOWN_PAR: IF FName = '' THEN
FName := Param
ELSE
ShowError(SYNTAX);
FILENAME_PAR: IF FName = '' THEN
FName := GetFirstWord(ParmLine, YES)
ELSE
ShowError(SYNTAX);
NOTAB_PAR: Separator := SPACE;
NOHEADER_PAR: PrintHeader := NO;
NOBASE_PAR: PrintBase := NO;
NOPRIVATE_PAR: PrintPrivate := NO
End { CASE }
End; { WHILE }
IF FName = EMPTYSTRING THEN
ShowError(NOFILENAME)
End;
{ ___ Extract Bias value from a ##bias directive _________________________ }
{ ________________________________________________________________________ }
FUNCTION GetBias(s:InString): long;
VAR
err: integer;
v: long;
Begin
Val(s, v, err);
IF err <> 0 THEN
ShowError(INVALIDBIAS);
GetBias := v
End;
{ ___ Compare each directive in InLine with directives list ______________ }
{ ________________________________________________________________________ }
FUNCTION CheckDirective(Dir: InString): DirectiveType;
VAR
z: integer;
cd: DirectiveType;
Begin
UpCaseStr(Dir);
z := CheckOption(CDIRECTIVES, Dir);
cd := UNKNOWN_DIR;
WHILE z > 0 DO Begin
cd := succ(cd);
Dec(z)
End;
CheckDirective := cd
End;
{ ___ Analyse each line and produce output _______________________________ }
{ ________________________________________________________________________ }
PROCEDURE ProcessLine(s:InString);
VAR
z: byte;
Begin
CASE s[1] OF
'*': ;
'#': CASE CheckDirective(GetFirstWord(s, YES)) OF
BIAS_DIR: bias := GetBias(s);
BASE_DIR: IF PrintBase THEN
BaseName := s;
PUBLIC_DIR: IsPublic := YES;
PRIVATE_DIR: IsPublic := NO;
END_DIR: ;
UNKNOWN_DIR: ShowError(UNKNOWNDIRECTIVE)
End;
OTHERWISE Begin
IF Bias = MAXLONGINT THEN
ShowError(NOBIAS);
IF (NOT HeaderOut) AND PrintHeader THEN Begin
HeaderOut := YES;
z := pos(FNAMEEND, FName);
IF z<>0 THEN
write(copy(FName,1,z-1))
ELSE
write(FName);
write(' Library Vectors Offsets');
IF (BaseName <> EMPTYSTRING) AND PrintBase THEN
writeln(' (Base name: ',BaseName,')')
ELSE
writeln
End;
IF PrintPrivate OR IsPublic THEN Begin
write(Bias:4,Separator,'$',Hex(65536-Bias,4),Separator);
writeln('-$',Hex(Bias,4),Separator,s)
End;
Bias := Bias + BIASSTEP
End
End
End;
{ ___ Open input file and do the real work _______________________________ }
{ ________________________________________________________________________ }
PROCEDURE ProcessFile;
Begin
{ ___ Try to open file ___________________________________________________ }
Assign(InFile, FName);
Reset(InFile);
IF IOResult <> 0 THEN Begin
Assign(InFile, FName + FNAMEEND);
Reset(InFile);
IF IOResult <> 0 THEN Begin
Assign(InFile, FDPATH + FName);
Reset(InFile);
IF IOResult <> 0 THEN Begin
Assign(InFile, FDPATH + FName + FNAMEEND);
Reset(InFile);
IF IOResult <> 0 THEN
ShowError(FILENOTFOUND);
End
End
End;
{$OPT B+} { the user can break from here }
{ ___ Scan file line by line, producing output ___________________________ }
REPEAT { Note that readln set EOF to TRUE }
readln(InFile,InLine); { when it reads the last line from }
ProcessLine(InLine) { the file, and not when it tries }
UNTIL EOF(InFile); { to read the (unexisting) next. }
{$OPT B-} { the user needs to break no more }
Close(InFile)
End;
{ ___ Set up the global variables ________________________________________ }
{ ________________________________________________________________________ }
PROCEDURE SetUpVars;
Begin
Bias := MAXLONGINT;
FName := EMPTYSTRING;
BaseName := EMPTYSTRING;
PrintHeader := YES;
PrintBase := YES;
PrintPrivate := YES;
Separator := TAB;
HeaderOut := NO;
IsPublic := YES
End;
{ ___ Main program _______________________________________________________ }
{ ________________________________________________________________________ }
Begin
SetUpVars;
AnalyzeParameterLine;
ProcessFile
End.
